
 1000  *SAVE S.DP18 FUNC 1
 1010  *--------------------------------
 1020  AS.CHRGOT  .EQ $00B7
 1030  AS.FRMEVL  .EQ $DD7B
 1040  AS.CHKSTR  .EQ $DD7B
 1050  AS.FRESTR  .EQ $E600
 1060  AS.ILLERR  .EQ $E199
 1070  *--------------------------------
 1080  DMULT      .EQ $FFFF
 1090  DDIV       .EQ $FFFF
 1100  DADD       .EQ $FFFF
 1110  FIN        .EQ $FFFF
 1120  DP.TRUE    .EQ $FFFF
 1130  DP.ZERO    .EQ $FFFF
 1140  MOVE.DAC.TEMP3 .EQ $FFFF
 1150  MOVE.DAC.TEMP2 .EQ $FFFF
 1160  MOVE.TEMP2.DAC .EQ $FFFF
 1170  MOVE.YA.DAC.1  .EQ $FFFF
 1180  MOVE.YA.ARG.1  .EQ $FFFF
 1190  MOVE.TEMP3.ARG .EQ $FFFF
 1200  MOVE.TEMP2.ARG .EQ $FFFF
 1210  *--------------------------------
 1220  TXTPTR     .EQ $B8,B9
 1230  DEST       .EQ $60,61
 1240  *--------------------------------
 1250  TEMP2      .BS 1
 1260  TEMP3      .BS 1
 1270  P1         .BS 2
 1280  DAC.EXPONENT .BS 1
 1290  DAC.HI       .BS 10
 1300  DAC.SIGN     .BS 1
 1310  *--------------------------------
 1320  *      VAL (X$) FUNCTION
 1330  *--------------------------------
 1340  DP.VAL JSR AS.CHRGOT
 1350         JSR AS.FRMEVL     GET STRING
 1360         JSR AS.CHKSTR MAKE SURE IT IS A STRING
 1370         LDA TXTPTR   SAVE TXTPTR
 1380         PHA          ...ON STACK
 1390         LDA TXTPTR+1
 1400         PHA
 1410         JSR AS.FRESTR FREE THE STRING;GET ADR IN
 1420         STX TXTPTR   Y,X AND LEN IN A
 1430         STX DEST    SAVE BEGINNING OF STRING
 1440         STY TXTPTR+1
 1450         STY DEST+1
 1460         TAY          LENGTH TO Y
 1470         STA TEMP2    SAVE LENGTH
 1480         LDA (TXTPTR),Y
 1490         PHA          SAVE CHAR AT END OF STRING
 1500         LDA #0
 1510         STA (TXTPTR),Y  PUT 0 AT END OF STRING
 1520         JSR FIN      GET THE NUMBER
 1530         PLA          GET CHAR
 1540         LDY TEMP2    GET LENGTH
 1550         STA (DEST),Y
 1560         PLA           RESTORE TXTPTR
 1570         STA TXTPTR+1
 1580         PLA
 1590         STA TXTPTR
 1600         RTS          VAL IS IN DAC
 1610  *--------------------------------
 1620  *      INT FUNCTION
 1630  *--------------------------------
 1640  DP.INT LDA DAC.EXPONENT
 1650         SEC
 1660         SBC #$40     REMOVE OFFSET
 1670         BPL .1       POSITIVE EXP
 1680  *---ALL FRACTION, MAKE = 0-------
 1690  .0     JMP DP.ZERO
 1700  *---SOME INTEGER, TRUNCATE-------
 1710  .1     BEQ .0       ...ALL FRACTION
 1720         CMP #20      ALL INTEGER?
 1730         BCS .4       ...YES, NONTHING TO LOP
 1740         LSR          DIVIDE BY 2
 1750         TAY          BYTE INDEX
 1760         BCC .3       ...NO NYBBLE TO CLEAR
 1770         LDA DAC.HI,Y ...CLEAR A NYBBLE
 1780         AND #$F0
 1790         STA DAC.HI,Y
 1800  .2     INY          ...NEXT BYTE
 1810         CPY #10      FINISHED?
 1820         BCS .4       ...YES
 1830  .3     LDA #0       CLEAR A BYTE
 1840         STA DAC.HI,Y
 1850         BEQ .2       ...ALWAYS
 1860  .4     RTS
 1870  *--------------------------------
 1880  *      ABS (DAC)
 1890  *--------------------------------
 1900  DP.ABS LDA #0       STORE 0 IN
 1910         STA DAC.SIGN SIGN
 1920         RTS
 1930  *--------------------------------
 1940  *      SGN (DAC)
 1950  *--------------------------------
 1960  DP.SGN LDA DAC.EXPONENT
 1970         BEQ .1       IT IS 0, SO LEAVE IT
 1980         LDA DAC.SIGN
 1990         PHA          SAVE SIGN
 2000         JSR DP.TRUE  PUT 1 IN DAC
 2010         PLA
 2020         STA DAC.SIGN RESTORE SIGN
 2030  .1     RTS
 2040  *--------------------------------
 2050  *      SQR (DAC)
 2060  *      #0072 IN HART, ET AL
 2070  *--------------------------------
 2080  ERR.SQ JMP AS.ILLERR  ILLEGAL QUANTITY
 2090  DP.SQR LDA DAC.EXPONENT
 2100         BEQ .3        SQR(0)=0
 2110         LDA DAC.SIGN
 2120         BMI ERR.SQ   MUST BE POSITIVE
 2130         JSR MOVE.DAC.TEMP3 SAVE X
 2140  *---REDUCE RANGE TO .1 - 1-------
 2150         LDA DAC.EXPONENT
 2160         PHA          SAVE EXPONENT
 2170         LDA #$40     CHANGE RANGE TO .1 THRU .9999...9
 2180         STA DAC.EXPONENT
 2190  *---REDUCE RANGE TO .25 - 1------
 2200         LDA DAC.HI
 2210         CMP #$25     LESS THAN .25?
 2220         PHP          SAVE ANSWER
 2230         BCS .4       ...NO
 2240         LDA #CON.FOUR
 2250         LDY /CON.FOUR
 2260         JSR MOVE.YA.ARG.1
 2270         JSR DMULT
 2280  *---CALC FIRST APPROX.-----------
 2290  .4     JSR MOVE.DAC.TEMP2
 2300         LDA #P.SQR   GET FIRST APPROXIMATION
 2310         LDY /P.SQR   FROM AX^3+BX^2+CX+D
 2320         LDX #P.SQR.N
 2330         JSR POLY.N
 2340  *---ADJUST APPROX FOR FOLDING----
 2350         PLP          WAS X<.25?
 2360         BCS .5       ...NO
 2370         LDA #CON.HALF
 2380         LDY /CON.HALF
 2390         JSR MOVE.YA.ARG.1
 2400         JSR DMULT
 2410  *---COMPUTE SQR EXPONENT---------
 2420  .5     PLA          GET EXPONENT FROM BEGINNING
 2430         SEC
 2440         SBC #$40     REMOVE OFFSET
 2450         ROR          DIVIDE BY TWO (KEEP SIGN)
 2460         EOR #$80
 2470         BCC .1       DON'T MULT BY SQR(10)
 2480  *---ADJUST APPROX FOR ODD EXP----
 2490         PHA          SAVE EXPONENT/2
 2500         LDA #CON.SQR10
 2510         LDY /CON.SQR10
 2520         JSR MOVE.YA.ARG.1
 2530         JSR DMULT
 2540         PLA
 2550  *---INSTALL NEW EXPONENT---------
 2560  .1     CLC
 2570         ADC DAC.EXPONENT
 2580         STA DAC.EXPONENT
 2590  *---THREE NEWTON ITERATIONS------
 2600         LDA #3
 2610         STA TEMP3
 2620  .2     JSR MOVE.DAC.TEMP2     TEMP2 = Y
 2630         JSR MOVE.TEMP3.ARG     GET X
 2640         JSR DDIV               X/Y
 2650         JSR MOVE.TEMP2.ARG
 2660         JSR DADD               X/Y+Y
 2670         LDA #CON.HALF
 2680         LDY /CON.HALF
 2690         JSR MOVE.YA.ARG.1
 2700         JSR DMULT              (X/Y+Y)/2
 2710         DEC TEMP3              ANY MORE?
 2720         BNE .2                 ...YES
 2730  .3     RTS                    ...DONE
 2740  *--------------------------------
 2750  P.SQR.N  .EQ 3
 2760  P.SQR      .HS 4028736982400000000000
 2770             .HS C082588889100000000000
 2780             .HS 4113225638600000000000
 2790             .HS 4021701867200000000000
 2800  CON.SQR10  .HS 4131622776601683793320
 2810  CON.HALF   .HS 4050000000000000000000
 2820  CON.FOUR   .HS 4140000000000000000000
 2830  *--------------------------------
 2840  *      POLYNOMIAL EVALUATOR ROUTINES
 2850  *      (Y,A) = ADDRESS OF COEFFICIENT TABLE
 2860  *      ARRANGED HIGHEST POWER TO LOWEST
 2870  *      CONSTANTS DO USE GUARD BYTE (11 TOTAL)
 2880  *--------------------------------
 2890  *   DO A POLYNOMIAL WITH 1ST CONSTANT 1
 2900  *      (TEMP2) IS X-VALUE
 2910  *      (X-REG) IS N
 2920  *           WHERE N = POWER OF X
 2930  *           FOR EXAMPLE, IF N=2 : X^2+AX+B
 2940  *                           N=4 : X^4+AX^3+BX^2+CX+D
 2950  *--------------------------------
 2960  POLY.1
 2970         STA P1
 2980         STY P1+1
 2990         STX TEMP3
 3000         JSR MOVE.TEMP2.DAC
 3010  POLY   LDA P1
 3020         LDY P1+1
 3030         JSR MOVE.YA.ARG.1
 3040         JSR DADD
 3050         DEC TEMP3    FINISHED YET?
 3060         BNE POLY2    ...NO
 3070         RTS          ...YES
 3080  *--------------------------------
 3090  *      DO A POLYNOMIAL WITH 1ST CONSTANT <> 1
 3100  *      (TEMP2) IS X-VALUE
 3110  *      (X-REG) IS N
 3120  *           WHERE N = POWER OF X
 3130  *           FOR EXAMPLE, IF N=2 : AX^2+BX+C
 3140  *                           N=3 : AX^3+BX^2+CX+D
 3150  *--------------------------------
 3160  POLY.N
 3170         STA P1
 3180         STY P1+1
 3190         STX TEMP3
 3200         JSR MOVE.YA.DAC.1
 3210  POLY2  JSR MOVE.TEMP2.ARG
 3220         JSR DMULT
 3230         CLC
 3240         LDA P1
 3250         ADC #11      NUMBER OF BYTES
 3260         STA P1
 3270         BCC POLY
 3280         INC P1+1
 3290         BNE POLY     ...ALWAYS
 3300  *--------------------------------

